COMMENT ⊗   VALID 00006 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	 the matching function  
C00005 00003	 The Simple Pattern Matcher
C00010 00004	 The Matcher
C00038 00005	 The Instantiator
C00042 00006	 Losing interns for the stupid COMPLR
C00056 ENDMK
C⊗;
;;;;;;;;;; the matching function ;;;;;;;;;; 
;;;
;;; (arg 1) - p -     pattern
;;; (arg 2) - d -     data
;;; (arg 3) - alist - optional list of variables (* or ?) whose values
;;; 		      are to be retained during the match, much like the
;;;		      = variables below.
;;; elements of a pattern:
;;;	? 	- matches anything
;;;	* 	- matches one or more expressions
;;;	?<atom> - like "?", but sets ?<atom> to thing matched
;;;	*<atom>	- like "*", but sets *<atom> to list of things matched
;;;	=<atom>	- matched against value of <atom>
;;;	(restrict <one of above ?-variables> <pred1> <pred2> .....)
;;;		- the predi must eval to non-nil
;;;	$r, ⊗r  - same as RESTRICT
;;;	(restrict <one of above *-variables> <pred1> <pred2> .....)
;;;		- the predi must eval to non-nil when given the list
;;;		  that is being considered for that variable as its argument
;;;	(irestrict <one of above *-variables> <pred1> <pred2> .....)
;;;		- the predi must eval to non-nil when given each element of the list
;;;		  that is being considered for that variable as its argument 
;;;		  (done incrementally). So %MATCH will apply these predicates as
;;;		  it scans the input.
;;;	$ir,⊗ir - same as irestrict
;;;
;;; (%match p d <variables to retain>) attempts to match p against d
;;; (%continue-match p d <variables to retain>) attempts to get the next
;;;		  possible match between p and d (by different *-variable
;;;		  bindings.
;;*PAGE
;;; The Simple Pattern Matcher
(DECLARE (SPECIAL %/#CONTINUE %/#CONTINUE-STACK %/#RETAIN %/#CE %/#ALIST COMPILE-MACROS))
(declare (fasload struct fas dsk (mac lsp)))
;;; Choice Macros

(DECLARE (SETQ DEFMACRO-FOR-COMPILING ()) 
	 (MAPEX T))

(EVAL-WHEN (COMPILE EVAL)
	   (DEFSTRUCT CHOOSER 
		      PAST-CHOICES ORIGINAL-DATA VARIABLE PREDICATES CHOICE EMPTY
		      SEARCH-LIST
		      CONSTANTP))

(DEFMACRO CHOOSEP (X) `(AND (NOT (ATOM ,X))
			    (MEMQ (CAR ,X) '($CHOOSE $CH))))

(DEFMACRO CHOOSE-VAR (X) `(CADR ,X))

(DEFMACRO EMPTY-CHOICE (X) `(EMPTY ,X))

(DEFMACRO COPY (X) `(MAPCAR (FUNCTION (LAMBDA (X) X)) ,X)))

(DEFUN %%CHOOSE-FIRST (P D)
       (%%CHOOSER
	(MAKE-CHOOSER PAST-CHOICES () ORIGINAL-DATA D
		      CONSTANTP (ATOM P)
		      SEARCH-LIST D
		      CHOICE ()
		      EMPTY ()
		      VARIABLE (COND ((ATOM P) P)
				     (T (CADR P)))
		      PREDICATES (COND ((ATOM P) ())
				       (T (CDDR P))))))

(DEFUN %%CHOOSE-NEXT (OLD-CHOOSER)
       (%%CHOOSER
	(MAKE-CHOOSER
	 PAST-CHOICES (PAST-CHOICES OLD-CHOOSER) 
	 ORIGINAL-DATA (ORIGINAL-DATA OLD-CHOOSER)
	 CONSTANTP (CONSTANTP OLD-CHOOSER)
	 SEARCH-LIST (SEARCH-LIST OLD-CHOOSER)
	 CHOICE ()
	 EMPTY ()
	 VARIABLE (VARIABLE OLD-CHOOSER)
	 PREDICATES (PREDICATES OLD-CHOOSER))))

(DEFMACRO NEXT-CHOICE (X) `(CHOICE ,X))


(DEFUN %%CHOOSER (CHOOSER)
 (LET ((P (VARIABLE CHOOSER))
       (D (COPY (ORIGINAL-DATA CHOOSER)))
       (SL (COPY (SEARCH-LIST CHOOSER))))
      (LET ((CH ()))
	   (COND ((CONSTANTP CHOOSER)
		  (COND ((SETQ SL (MEMQ P SL))
			 (SETQ CH `(,P . ,(DELQ P D))) 
			 (COND ((MEMBER CH (PAST-CHOICES CHOOSER))
				(SETF (EMPTY CHOOSER) T))
			       (T (SETF (CHOICE CHOOSER) CH)
				  (SETF (SEARCH-LIST CHOOSER) (CDR SL))
				  (SETF (PAST-CHOICES CHOOSER)
					`(,CH . ,(PAST-CHOICES CHOOSER))))))
			(T (SETF (EMPTY CHOOSER) T))))
		 (T (LET ((CAND (%%SEARCH (PREDICATES CHOOSER) SL)))
			 (COND (CAND
				(SETQ CH `(,(CAR CAND) 
					   . ,(DELQ (CAR CAND)
						      D)))
				(COND ((MEMBER CH (PAST-CHOICES CHOOSER))
				       (SETF (EMPTY CHOOSER) T)) 
				      (T (SETF (CHOICE CHOOSER) CH)
					 (SETF (SEARCH-LIST CHOOSER) (CDR CAND))
					 (SETF (PAST-CHOICES CHOOSER)
					       `(,CH . ,(PAST-CHOICES CHOOSER))))))
				     (T (SETF (EMPTY CHOOSER) T))))))))  
 CHOOSER)

(DEFUN %%SEARCH (PREDS L)
       (DO ((L L (CDR L)))
	   ((NULL L) ())
	   (COND ((APPLY 'AND
			 (MAPCAR (FUNCTION (LAMBDA (F)
						   (FUNCALL F (CAR L))))
				 PREDS))
		  (RETURN L)))))

(MACRODEF CHOOSE-CLAUSE (P D CP CD ALIST)
 (LET ((PAT (CHOOSE-VAR (CAR P))))
       (DO ((DAT (%%CHOOSE-FIRST PAT D)
		 (%%CHOOSE-NEXT DAT)))
	   ((EMPTY-CHOICE DAT) (*THROW '%/#DECISION-POINT ()))
	   (COND ((*CATCH '%/#DECISION-POINT
			  (%%MATCH 
			   (CONS PAT (CDR P))
			   (NEXT-CHOICE DAT) CP CD ALIST))
		  (*THROW '%/#DECISION-POINT T))))))

;;; The Matcher
;;; %/#CONTINUE is T if this is a rematch. %/#RETAIN says
;;; whether or not to save information for a rematch
;;; %/#CONTINUE-STACK saves * information for the rematch
(DECLARE (SETSYNTAX 35. 2 35.))
(SETQ %/#CONTINUE NIL %/#CONTINUE-STACK NIL %/#RETAIN NIL COMPILE-MACROS NIL)

;;; (MATCH <pat> <data> <initial alist, optional>)
(DEFUN %MATCH %/#n 
 ((LAMBDA(%/#CONTINUE)
       (SETQ %/#CONTINUE-STACK NIL)
       (*CATCH '%/#DECISION-POINT
	      (%%MATCH (ARG 1) (ARG 2) NIL NIL
	(COND ((< 2 %/#n)(MAPCAR (FUNCTION (LAMBDA(%/#Q)(CONS %/#Q (SYMEVAL %/#Q))))
			      (ARG 3))))) )) NIL))

;;; (%CONTINUE-MATCH <pat> <data> <* stack> <intitial alist, optional>)
(DEFUN %CONTINUE-MATCH %/#n 
	((LAMBDA(%/#CONTINUE)
		(SETQ %/#CONTINUE-STACK (ARG 3))
		(*CATCH '%/#DECISION-POINT
		       (%%MATCH (ARG 1)(ARG 2) NIL NIL 
		 (COND ((< 3 %/#n)(MAPCAR (FUNCTION (LAMBDA(%/#Q)(CONS %/#Q (SYMEVAL %/#Q))))
			      (ARG 4))))) )) 
	T))

;;; %/#P is the pattern
;;; %/#D is the data
;;; %/#CP is the pattern to match against %/#CD if %/#P and %/#D match (i.e. a continuation)
;;; %/#CD is the data for the continuation
;;; ALIST is the current alist


(MACRODEF %%CHAR1 (ATOM) 
       ;; returns the 1st character of an atom.
       (COND ((EQ (TYPEP ATOM) 'SYMBOL) (GETCHAR ATOM 1.))))

(MACRODEF REAL-ATOM (%/#X)(OR (AND %/#X (ATOM %/#X)) (HUNKP %/#X)))

(MACRODEF ALL-TRUE (FUN %/#L)
 (APPLY 'AND (MAPCAR (FUNCTION  (LAMBDA (%Q%)(COND ((FUNCALL FUN %Q%) T))))
		     %/#L)))

(MACRODEF RESTRICTP (%/#X) (AND (NOT (ATOM %/#X))
			     (MEMQ (CAR %/#X) '($R RESTRICT ⊗R $IR IRESTRICT ⊗IR))))

(DEFUN %%MATCH (%/#P %/#D %/#CP %/#CD %/#ALIST) 
(PROG NIL
 MATCH
   (OR
	(COND
	 ;;; no more pattern
	 ((AND (NULL %/#P) (NULL %/#CP))
	  ;;; so there had better be no more data
	  (COND ((AND (NULL %/#D)(NULL %/#CD))
		 ;;; if this is a rematch, we back up for next try
		 (COND (%/#CONTINUE (SETQ %/#CONTINUE NIL)
			(*THROW '%/#DECISION-POINT NIL ))
			;;; otherwise success
		       ((*THROW '%/#DECISION-POINT T ))))
	        ;;; more data loses
	  	((*THROW '%/#DECISION-POINT NIL ))))
	 ((NULL %/#P)
	  ;;; if %/#P is null, but %/#D isn't, something is wrong
	  (COND (%/#D (*THROW '%/#DECISION-POINT NIL ))
		(T (SETQ %/#P (CAR %/#CP) %/#D (CAR %/#CD) %/#CP (CDR %/#CP) %/#CD (CDR %/#CD))
		   (GO MATCH))))
	 ((AND (NULL %/#D)
	       (NOT (RESTRICTP (CAR %/#P))))
	  ;;; if %/#D is null and %/#P isn't, we can still win
	  (COND ((OR (ATOM %/#P)
		     (MEMQ (CAR %/#P) '($R RESTRICT ⊗R $IR IRESTRICT ⊗IR)))
		 ;;; if %/#P=?<var> or = nil
		 (SETQ %/#P (NCONS %/#P) %/#D '(NIL))
		 (GO MATCH))
		((EQ (CAR %/#P) '*)
		 ;;; %/#P=(* ...) could work if (CDR %/#P) is all *-variables
		 (SETQ %/#P (CDR %/#P))
		 (GO MATCH))
		((EQ (%%CHAR1 (CAR %/#P)) '*)
		  ;;; we succeed if (CAR %/#P) = (*<var> ...) and *<var> matched 0 elements.
		  ((LAMBDA(%T%)
			(COND (%T% (SETQ %/#P (APPEND (CDR %T%)(CDR %/#P)))
				   (GO MATCH))
 			      (T (COND ((*CATCH '%/#DECISION-POINT
					       (%%MATCH (CDR %/#P) NIL %/#CP %/#CD
				                        (CONS (CONS (CAR %/#P) NIL)
							      %/#ALIST)) )
			                (SET (CAR %/#P) NIL)
			                (*THROW '%/#DECISION-POINT T ))
				       (T (*THROW '%/#DECISION-POINT () )))))) 
		 (ASSQ (CAR %/#P) %/#ALIST)))
		   (T (*THROW '%/#DECISION-POINT ()))
		))
	 ((OR (ATOM %/#P) (REAL-ATOM %/#D)
	      (RESTRICTP %/#P)(RESTRICTP %/#D))
 	  ;;; here we listify things if necessary
	  (SETQ %/#P (NCONS %/#P) %/#D (NCONS %/#D))
	  (GO MATCH))
	 ;;; restrictions
	 ((AND (NOT (ATOM (CAR %/#P)))
	       (MEMQ (CAAR %/#P) '($R RESTRICT ⊗R))
	       (EQ (%%CHAR1 (CADAR %/#P)) '?) 
	       (NOT (NULL %/#D))
	       (APPLY 'AND
		      (MAPCAR 
        	       (FUNCTION (LAMBDA (%/#PRED) (COND ((FUNCALL %/#PRED (CAR %/#D))
							T))))
		       (CDDAR %/#P))))
	  (COND
	   ((EQ (CADAR %/#P) '?)
	    ;;; normal case of ($r ? ...)
	    (SETQ %/#P (CDR %/#P) %/#D (CDR %/#D))
	    (GO MATCH))
	   ((EQ (%%CHAR1 (CADAR %/#P)) '?)
	    ;;; case of ($r ?foo ...)
	    ((LAMBDA (%T%) 
	      (COND (%T% (SETQ %/#P (CONS (CDR %T%) (CDR %/#P)))
			 (GO MATCH))
		    (T (COND ((*CATCH '%/#DECISION-POINT
				     (%%MATCH (CDR %/#P)(CDR %/#D) %/#CP %/#CD
					      (CONS (CONS (CADAR %/#P)
							  (CAR %/#D))
						    %/#ALIST))
				     )
			      (SET (CADAR %/#P) (CAR %/#D))
			      (*THROW '%/#DECISION-POINT T ))
			     (T (*THROW '%/#DECISION-POINT () ))))))
	     (ASSQ (CADAR %/#P) %/#ALIST)))  
	   ((EQ (%%CHAR1 (CADAR %/#P)) '=)
	    ;;; case of ($r ?foo ...)
	    (SETQ %/#P (CONS (CADAR %/#P) (CDR %/#P)))
	    (GO MATCH))))

	 ((AND (NOT (ATOM (CAR %/#P)))
	       (MEMQ (CAAR %/#P) '($R RESTRICT ⊗R)))
	  (COND ((EQ (CADAR %/#P) '*)
		 (COND ((NULL (CDR %/#P))
			(COND
			 ((APPLY 'AND
				 (MAPCAR (FUNCTION
					  (LAMBDA (%/#Q)
						  (COND 
						   ((FUNCALL %/#Q %/#D)
						    T))))
					 (CDDAR %/#P)))   
			  (SETQ %/#P (CAR %/#CP) %/#D (CAR %/#CD) %/#CP (CDR %/#CP) %/#CD (CDR %/#CD))
			  (GO MATCH))
			 (T (*THROW '%/#DECISION-POINT NIL ))))
		       (T ((LAMBDA (%/#L)
				   (COND (%/#CONTINUE
					  ;(OR %/#CONTINUE-STACK (*THROW '%/#DECISION-POINT NIL ))
					  ;;; initialize for continuation
					  (SETQ %/#L (PROG2 NIL (CAR %/#CONTINUE-STACK)
							 (SETQ %/#CONTINUE-STACK 
							       (CDR %/#CONTINUE-STACK))))
					  (SETQ %/#D (DO ((%/#L %/#L (CDR %/#L))
						       (%/#D %/#D (CDR %/#D)))
						      ((NULL %/#L) %/#D)))
					  (COND ((NULL %/#D)
						 (SETQ %/#P (CDR %/#P))
						 (GO MATCH))))
					 (T (SETQ %/#L NIL)))
				   ;;; try all possibilities
				   (DO ((%/#L %/#L (NCONC %/#L (NCONS (CAR %/#D))))
					(%/#D %/#D (CDR %/#D))
					(%/#E (CONS NIL %/#D) (CDR %/#E)))
				       ((NULL %/#E) (*THROW '%/#DECISION-POINT NIL ))
				       (COND ((APPLY 'AND
						     (MAPCAR 
						      (FUNCTION
						       (LAMBDA (%/#Q)
							       (COND
								((FUNCALL %/#Q %/#L)
								 T))))
						      (CDDAR %/#P))) 
					      (COND ((*CATCH '%/#DECISION-POINT
							    (%%MATCH (CDR %/#P)	%/#D %/#CP %/#CD
								     %/#ALIST) 
							    )
						     (AND %/#RETAIN (SETQ %/#CONTINUE-STACK
									 (CONS %/#L %/#CONTINUE-STACK)))
						     (*THROW '%/#DECISION-POINT T ))))))) NIL))))   
		((EQ (%%CHAR1 (CADAR  %/#P)) '*)
		 ((LAMBDA (%T%) 
			   (COND (%T% (COND((APPLY 'AND
						   (MAPCAR
						    (FUNCTION
						     (LAMBDA (%/#Q)
							     (COND ((FUNCALL %/#Q
									   (CDR %T%))
								    T))))
						     (CDDAR %/#P)))
						   (SETQ %/#P (APPEND (CDR %T%) (CDR %/#P)))
						   (GO MATCH)) 
					    (T (*THROW '%/#DECISION-POINT NIL ))))
				  ((NULL (CDR %/#P))
				   (COND ((APPLY
					   'AND
					   (MAPCAR
					    (FUNCTION
					     (LAMBDA (%/#Q)
						     (COND 
						      ((FUNCALL
							%/#Q
							%/#D)
						       T))))(CDDAR %/#P)))
					  (COND ((*CATCH '%/#DECISION-POINT
							(%%MATCH (CAR %/#CP) (CAR %/#CD) (CDR %/#CP)
								 (CDR %/#CD)
								 (CONS (CONS (CADAR %/#P) %/#D)
								       %/#ALIST))
							)
						 (SET (CADAR %/#P) %/#D)
						 (*THROW '%/#DECISION-POINT T ))
						(T (*THROW '%/#DECISION-POINT () )))) 
					 (T (*THROW '%/#DECISION-POINT NIL ))))
				  (T ((LAMBDA(%/#L)
				       (COND (%/#CONTINUE
					      (SETQ %/#L (SYMEVAL (CAR %/#P)))
					      (SETQ %/#D (DO ((%/#L %/#L (CDR %/#L))
							   (%/#D %/#D (CDR %/#D)))
							  ((NULL %/#L) %/#D)))
					      (COND ((NULL %/#D)
						     (SETQ %/#P (CDR %/#P))
						     (GO MATCH))))
					     (T (SETQ %/#L NIL)))
				       (DO ((%/#L %/#L (NCONC %/#L (NCONS (CAR %/#D))))
					    (%/#D %/#D (CDR %/#D))
					    (%/#E (CONS NIL %/#D) (CDR %/#E)))
					   ((NULL %/#E) (*THROW '%/#DECISION-POINT NIL ))
					   (COND
					    ((APPLY
					      'AND
					      (MAPCAR
					       (FUNCTION
						(LAMBDA (%/#Q)
							(COND ((FUNCALL %/#Q %/#L)
							       T))))
					       (CDDAR %/#P)))
					     (COND ((*CATCH '%/#DECISION-POINT
							   (%%MATCH (CDR %/#P)	%/#D %/#CP %/#CD
								    (CONS (CONS (CADAR %/#P) %/#L)
									  %/#ALIST))
							   )
						    (SET (CADAR %/#P) %/#L)
						    (*THROW '%/#DECISION-POINT T ))))))) NIL))))
	   (ASSQ (CADAR %/#P) %/#ALIST)) )
         ((EQ (%%CHAR1 (CADAR  %/#P)) '=)
	  ((LAMBDA (VAR)
		   ((LAMBDA (VAL)
			    (COND (VAL 
				   (SETQ %/#P (CONS (LIST (CAAR %/#P) VAR (CDDAR %/#P))
						   (CDR %/#P)))) 
				  (T (SETQ %/#P (CONS (LIST (CAAR %/#P) VAR (CDDAR %/#P))
						     (CDR %/#P))
					   %/#ALIST (CONS (CONS VAR (SYMEVAL VAR))
							 %/#ALIST)))))
		    (ASSQ VAR %/#ALIST)))
	   (IMPLODE (CDR (EXPLODE (CADAR %/#P)))))
	   (GO MATCH)) ))     

	 ((AND (NOT (ATOM (CAR %/#P)))
	       (MEMQ (CAAR %/#P) '($IR IRESTRICT ⊗IR)))
	  (COND ((EQ (CADAR %/#P) '*)
		 (COND ((NULL (CDR %/#P))
			(COND
			 ((APPLY 'AND
				 (MAPCAR (FUNCTION
					  (LAMBDA (%/#Q)
						  (COND 
						   ((ALL-TRUE %/#Q %/#D)
						    T))))
					 (CDDAR %/#P)))   
			  (SETQ %/#P (CAR %/#CP) %/#D (CAR %/#CD) %/#CP (CDR %/#CP) %/#CD (CDR %/#CD))
			  (GO MATCH))
			 (T (*THROW '%/#DECISION-POINT NIL ))))
		       (T ((LAMBDA (%/#L)
				   (COND (%/#CONTINUE
					  ;(OR %/#CONTINUE-STACK (*THROW '%/#DECISION-POINT NIL ))
					  ;;; initialize for continuation
					  (SETQ %/#L (PROG2 NIL (CAR %/#CONTINUE-STACK)
							 (SETQ %/#CONTINUE-STACK 
							       (CDR %/#CONTINUE-STACK))))
					  (SETQ %/#D (DO ((%/#L %/#L (CDR %/#L))
						       (%/#D %/#D (CDR %/#D)))
						      ((NULL %/#L) %/#D)))
					  (COND ((NULL %/#D)
						 (SETQ %/#P (CDR %/#P))
						 (GO MATCH))))
					 (T (SETQ %/#L NIL)))
				   ;;; try all possibilities
				   (DO ((%/#L %/#L (NCONC %/#L (NCONS (CAR %/#D))))
					(%/#F (CAR %/#D)(CAR %/#D))
					(%/#D %/#D (CDR %/#D))
					(%/#E (CONS NIL %/#D) (CDR %/#E)))
				       ((NULL %/#E) (*THROW '%/#DECISION-POINT NIL ))
				       (COND ((APPLY 'AND
						     (MAPCAR 
						      (FUNCTION
						       (LAMBDA (%/#Q)
							       (COND
								((OR (NULL %/#L)
								     (FUNCALL %/#Q %/#F))
								 T))))
						      (CDDAR %/#P))) 
					      (COND ((*CATCH '%/#DECISION-POINT
							    (%%MATCH (CDR %/#P)	%/#D %/#CP %/#CD
								     %/#ALIST) 
							    )
						     (AND %/#RETAIN (SETQ %/#CONTINUE-STACK
									 (CONS %/#L %/#CONTINUE-STACK)))
						     (*THROW '%/#DECISION-POINT T )))) 
					     (T (*THROW '%/#DECISION-POINT NIL ))))) NIL))))   
		((EQ (%%CHAR1 (CADAR  %/#P)) '*)
		 ((LAMBDA (%T%) 
			   (COND (%T% (COND((APPLY 'AND
						   (MAPCAR
						    (FUNCTION
						     (LAMBDA (%/#Q)
						      (COND ((ALL-TRUE %/#Q %T%)
							     T))))
						     (CDDAR %/#P)))
						   (SETQ %/#P (APPEND (CDR %T%) (CDR %/#P)))
						   (GO MATCH)) 
					    (T (*THROW '%/#DECISION-POINT NIL ))))
				  ((NULL (CDR %/#P))
				   (COND ((APPLY
					   'AND
					   (MAPCAR
					    (FUNCTION
					     (LAMBDA (%/#Q)
						     (COND 
						      ((ALL-TRUE 
							%/#Q
							%/#D)
						       T))))(CDDAR %/#P)))
					  (COND ((*CATCH '%/#DECISION-POINT
							(%%MATCH (CAR %/#CP) (CAR %/#CD) (CDR %/#CP)
								 (CDR %/#CD)
								 (CONS (CONS (CADAR %/#P) %/#D)
								       %/#ALIST))
							)
						 (SET (CADAR %/#P) %/#D)
						 (*THROW '%/#DECISION-POINT T ))
						(T (*THROW '%/#DECISION-POINT () )))) 
					 (T (*THROW '%/#DECISION-POINT NIL ))))
				  (T ((LAMBDA(%/#L)
				       (COND (%/#CONTINUE
					      (SETQ %/#L (SYMEVAL (CAR %/#P)))
					      (SETQ %/#D (DO ((%/#L %/#L (CDR %/#L))
							   (%/#D %/#D (CDR %/#D)))
							  ((NULL %/#L) %/#D)))
					      (COND ((NULL %/#D)
						     (SETQ %/#P (CDR %/#P))
						     (GO MATCH))))
					     (T (SETQ %/#L NIL)))
				       (DO ((%/#L %/#L (NCONC %/#L (NCONS (CAR %/#D))))
					    (%/#F (CAR %/#D)(CAR %/#D))
					    (%/#D %/#D (CDR %/#D))
					    (%/#E (CONS NIL %/#D) (CDR %/#E)))
					   ((NULL %/#E) (*THROW '%/#DECISION-POINT NIL ))
					   (COND
					    ((APPLY
					      'AND
					      (MAPCAR
					       (FUNCTION
						(LAMBDA (%/#Q)
							(COND ((OR (NULL %/#L)
								   (FUNCALL %/#Q %/#F))
							       T))))
					       (CDDAR %/#P)))
					     (COND ((*CATCH '%/#DECISION-POINT
							   (%%MATCH (CDR %/#P)	%/#D %/#CP %/#CD
								    (CONS (CONS (CADAR %/#P) %/#L)
									  %/#ALIST))
							   )
						    (SET (CADAR %/#P) %/#L)
						    (*THROW '%/#DECISION-POINT T ))))
					    (T (*THROW '%/#DECISION-POINT NIL ))))) NIL))))
	   (ASSQ (CADAR %/#P) %/#ALIST)) )

         ((EQ (%%CHAR1 (CADAR  %/#P)) '=)
	  ((LAMBDA (VAR)
		   ((LAMBDA (VAL)
			    (COND (VAL 
				   (SETQ %/#P (CONS (LIST (CAAR %/#P) VAR (CDDAR %/#P))
						   (CDR %/#P)))) 
				  (T (SETQ %/#P (CONS (LIST (CAAR %/#P) VAR (CDDAR %/#P))
						     (CDR %/#P))
					   %/#ALIST (CONS (CONS VAR (SYMEVAL VAR))
							 %/#ALIST)))))
		    (ASSQ VAR %/#ALIST)))
	   (IMPLODE (CDR (EXPLODE (CADAR %/#P)))))
	   (GO MATCH)) ))

	 ((OR (EQUAL (CAR %/#P) (CAR %/#D)) (EQ (CAR %/#P) '?))
	  ;;; easiest case
	  (SETQ %/#P (CDR %/#P) %/#D (CDR %/#D))
	  (GO MATCH))
	 ((EQ (%%CHAR1 (CAR %/#P)) '?)
	  ;;; (?foo ...)
	  ((LAMBDA (%T%) 
	    (COND (%T% (SETQ %/#P (CONS (CDR %T%) (CDR %/#P)))
		       (GO MATCH))
		  (T (COND ((*CATCH '%/#DECISION-POINT
				   (%%MATCH (CDR %/#P)(CDR %/#D) %/#CP %/#CD
					    (CONS (CONS (CAR %/#P)
							(CAR %/#D))
						  %/#ALIST))
				   )
			    (SET (CAR %/#P) (CAR %/#D))
			    (*THROW '%/#DECISION-POINT T ))
			   (T (*THROW '%/#DECISION-POINT () ))))))
	    (ASSQ (CAR %/#P) %/#ALIST)))


         ((EQ (CAR %/#P) '*)
	  ;;; (* ...)

	  (COND ((NULL (CDR %/#P))
		 (SETQ %/#P (CAR %/#CP) %/#D (CAR %/#CD) %/#CP (CDR %/#CP) %/#CD (CDR %/#CD))
		 (GO MATCH))
	        (T ((LAMBDA (%/#L)
		      (COND (%/#CONTINUE
			    ;(OR %/#CONTINUE-STACK (*THROW '%/#DECISION-POINT NIL ))
			    ;;; initialize for continuation
			    (SETQ %/#L (PROG2 NIL (CAR %/#CONTINUE-STACK)
					   (SETQ %/#CONTINUE-STACK 
						 (CDR %/#CONTINUE-STACK))))
			    (SETQ %/#D (DO ((%/#L %/#L (CDR %/#L))
					 (%/#D %/#D (CDR %/#D)))
					 ((NULL %/#L) %/#D)))
			    (COND ((NULL %/#D)
				   (SETQ %/#P (CDR %/#P))
				   (GO MATCH))))
			    (T (SETQ %/#L NIL)))
		     ;;; try all possibilities
		     (DO ((%/#L %/#L (NCONC %/#L (NCONS (CAR %/#D))))
			  (%/#D %/#D (CDR %/#D))
			  (%/#E (CONS NIL %/#D) (CDR %/#E)))
			 ((NULL %/#E) (*THROW '%/#DECISION-POINT NIL ))
			 (COND ((*CATCH '%/#DECISION-POINT
				       (%%MATCH (CDR %/#P)	%/#D %/#CP %/#CD
						%/#ALIST) 
				       )
				(AND %/#RETAIN (SETQ %/#CONTINUE-STACK
						    (CONS %/#L %/#CONTINUE-STACK)))
				(*THROW '%/#DECISION-POINT T )))))NIL))))

	 ((EQ (%%CHAR1 (CAR %/#P)) '*)
	  ;;; similar for (*foo ...)
	  ((LAMBDA (%T%) 
	    (COND (%T% (SETQ %/#P (APPEND (CDR %T%) (CDR %/#P)))
		       (GO MATCH))
		  ((NULL (CDR %/#P))
		   (COND ((*CATCH '%/#DECISION-POINT
				 (%%MATCH (CAR %/#CP) (CAR %/#CD) (CDR %/#CP)
					  (CDR %/#CD)
					  (CONS (CONS (CAR %/#P) %/#D)
						%/#ALIST))
				 )
			  (SET (CAR %/#P) %/#D)
			  (*THROW '%/#DECISION-POINT T ))
			 (T (*THROW '%/#DECISION-POINT () ))))
		  (T ((LAMBDA(%/#L)
		      (COND (%/#CONTINUE
			    (SETQ %/#L (SYMEVAL (CAR %/#P)))
			    (SETQ %/#D (DO ((%/#L %/#L (CDR %/#L))
					 (%/#D %/#D (CDR %/#D)))
					((NULL %/#L) %/#D)))
			    (COND ((NULL %/#D)
				   (SETQ %/#P (CDR %/#P))
				   (GO MATCH))))
			   (T (SETQ %/#L NIL)))
		     (DO ((%/#L %/#L (NCONC %/#L (NCONS (CAR %/#D))))
			  (%/#D %/#D (CDR %/#D))
			  (%/#E (CONS NIL %/#D) (CDR %/#E)))
			 ((NULL %/#E) (*THROW '%/#DECISION-POINT NIL ))
			 (COND ((*CATCH '%/#DECISION-POINT
				       (%%MATCH (CDR %/#P)	%/#D %/#CP %/#CD
						(CONS (CONS (CAR %/#P) %/#L)
  						      %/#ALIST))
				       )
				(SET (CAR %/#P) %/#L)
				(*THROW '%/#DECISION-POINT T ))))) NIL))))
	   (ASSQ (CAR %/#P) %/#ALIST)) )

	 ((EQ (%%CHAR1 (CAR %/#P)) '=)
	   ;;; (=?foo ...)
	  ((LAMBDA (%T%) 
		   (COND ((EQ (CAR %T%) '?)
			  ((LAMBDA (VAR)
			    ((LAMBDA (VAL)
			      (COND (VAL (SETQ %/#P (CONS (CDR VAL) (CDR %/#P))))
				    (T
			             (SETQ %/#P 
					   (CONS (SYMEVAL VAR) (CDR %/#P))))) 
			      (GO MATCH))
			     (ASSQ VAR %/#ALIST)))
		  	    (IMPLODE %T%)))
			 (T 
			  ((LAMBDA (VAR)
			    ((LAMBDA (VAL)
			      (COND (VAL (SETQ %/#P (APPEND (CDR VAL) (CDR %/#P))))
				    (T
			             (SETQ %/#P 
					   (APPEND (SYMEVAL VAR) (CDR %/#P))))) 
			      (GO MATCH))
			     (ASSQ VAR %/#ALIST)))
		  	    (IMPLODE %T%)))))
	   (CDR (EXPLODE (CAR %/#P)))))   

         ((CHOOSEP (CAR %/#P))
	  (CHOOSE-CLAUSE  %/#P %/#D %/#CP %/#CD %/#ALIST))

	 ((AND (NOT (ATOM (CAR %/#P))) 
	       (OR (NULL (CAR %/#D))(NOT (ATOM (CAR %/#D)))))
	  ;;; the big recursion
	  ;;; notice that we want nil to be a list here, not an atom
	  ;;; since ((*) ...) (nil ...) needs a chance
	  (SETQ 
		%/#CP (CONS (CDR %/#P) %/#CP) 
		%/#CD (CONS (CDR %/#D) %/#CD)
		%/#P (CAR %/#P) %/#D (CAR %/#D))
	  (GO MATCH))) 
     (*THROW '%/#DECISION-POINT NIL )))) 



(DEFUN %CHAR1 (%/#ATOM) 
       ;; returns the 1st character of an atom.
       (COND ((EQ (TYPEP %/#ATOM) 'SYMBOL) (GETCHAR %/#ATOM 1.))))

(DEFUN %MATCH-LOOKUP (%/#X)
 (CDR (ASSQ %/#X %/#ALIST)))

;;*page 
;;; The Instantiator

(MACRODEF %CHAR1 (ATOM) 
       ;; returns the 1st character of an atom.
       (COND ((EQ (TYPEP ATOM) 'SYMBOL) (GETCHAR ATOM 1.))))

(DECLARE (SPECIAL -SEEN-))

(DEFUN %INSTANTIATE (PAT) 
  ((LAMBDA (-SEEN-)
    (%INSTANTIATE1 PAT))
   ()))

(DEFUN %INSTANTIATE1 (PAT)
       ;;; instantiates pattern.
       ;;; ?ce		: the ce
       ;;; ?<atom>	: value of ?<atom> used
       ;;; *<atom>	: value of *<atom> spliced in
       (COND ((ATOM PAT)
	      (COND ((EQ PAT '?CE) (SUBST NIL NIL %/#CE))
		    ((EQ PAT '?) '-QUESTION-MARK-)
		    ((EQ PAT '*)'-STAR-)
		    ((MEMQ PAT '(? *)) PAT)
		    ((EQ (%CHAR1 PAT) '→) (IMPLODE (CDR (EXPLODE PAT))))
		    ((MEMQ (%CHAR1 PAT) '(* ?))
		     (COND ((BOUNDP PAT) 
			    (%%COPY (SYMEVAL PAT)))
			   (T PAT)))
		    (PAT)))
	     ((HUNKP PAT) PAT)
	     ((EQ (CAR PAT) '*)
	      (CONS '-STAR- (%INSTANTIATE1 (CDR PAT))))
	     ((EQ (%CHAR1 (CAR PAT)) '*)
	      (APPEND 
	       (COND ((BOUNDP (CAR PAT))
		      (SYMEVAL (CAR PAT)))
		     (T (CAR PAT)))
	       (%INSTANTIATE1 (CDR PAT))))
	     ((MEMQ (CAR PAT) '(RESTRICT $R ⊗R IRESTRICT $IR ⊗IR))
	      (%INSTANTIATE1 (CADR PAT)))
	     ((MEMQ PAT -SEEN-) PAT)
	     (T (PUSH PAT -SEEN-)
		(CONS (%INSTANTIATE1 (CAR PAT))
		      (%INSTANTIATE1 (CDR PAT)))))) 


(DEFUN %%COPY (X)
 ((LAMBDA (-SEEN-)
  (%%COPY1 X)) ()))

(DEFUN %%COPY1 (X)
 (COND ((NULL X) ())
       ((ATOM X) X)
       ((HUNKP X) X)
       ((MEMQ X -SEEN-) X)
       (T (PUSH X -SEEN-)
	  (CONS (%%COPY1 (CAR X))
		(%%COPY1 (CDR X))))))

;;*page 
;;; Losing interns for the stupid COMPLR
(intern '/←)
(intern 'then)
(intern 'do)
(intern 'execute)
(intern 'defmacro)
(intern 'meanwhle)
(intern 'let/!)